home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / lists.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  4KB  |  179 lines
  1. /* ******************************************************************** */
  2. /* lists.c           Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* basic list operations                                        */
  5. /* ******************************************************************** */
  6.  
  7. #define JMPDBG(x)
  8.  
  9. /*
  10.  * Change Log:
  11.  *   Version 1, March 1990 (Compiler rationalisation)
  12.  *     Verified GC proof.
  13.  */
  14.  
  15. #include <string.h>
  16. #include "funcalls.h"
  17. #include "defs.h"
  18. #include "structs.h"
  19. #include "error.h"
  20. #include "global.h"
  21.  
  22. #include "allocate.h"
  23. #include "modboot.h"
  24.  
  25. EUFUN_1( Fn_consp, form)
  26. {
  27.   return (is_cons(form) ? lisptrue : nil);
  28. }
  29. EUFUN_CLOSE
  30.  
  31. EUFUN_1( Fn_car, x)
  32. {
  33.  
  34.   while (TRUE) {
  35.     if (is_cons(x)) return (x->CONS).car;
  36.                 /* Illegal car; needs to act on signals */
  37.                 /* Until that is fixed just stop        */
  38.     x = CallError(stacktop,"car: ~a is not list",x,CONTINUABLE);
  39.   }
  40.  
  41.   return(nil); /* dummy */
  42. }
  43. EUFUN_CLOSE
  44.  
  45. EUFUN_2( car_updator,  x, y)
  46. {
  47.   while (!is_cons(x))
  48.     x = CallError(stacktop,"car_updator: attempt to rplaca into atom ~a", x,
  49.           CONTINUABLE);
  50.   (x->CONS).car = y;
  51.   return y;
  52. }
  53. EUFUN_CLOSE
  54.  
  55. EUFUN_1( Fn_cdr, x)
  56. {
  57.  
  58.   while (TRUE) {
  59.     if (is_cons(x)) return (x->CONS).cdr;
  60.                 /* Illegal car; needs to act on signals */
  61.                 /* Until that is fixed just stop        */
  62.     x = CallError(stacktop,"cdr: ~a is not list",x,CONTINUABLE);
  63.   }
  64.  
  65.   return(nil); /* dummy */
  66. }
  67. EUFUN_CLOSE
  68.  
  69. EUFUN_2( cdr_updator,  x, y)
  70. {
  71.   while (!is_cons(x))
  72.     x = CallError(stacktop,"cdr_updator: attempt to rplacd into atom ~a", x,
  73.           CONTINUABLE);
  74.   (x->CONS).cdr = y;
  75.   return y;
  76. }
  77. EUFUN_CLOSE
  78.  
  79.                 /* Length of a list; does not check */
  80. EUFUN_1( Fn_length, form)
  81. {
  82.   int i = 0;
  83.  
  84.   while (is_cons(form)) {
  85.     i++;
  86.     form = CDR(form);
  87.   }
  88.   return allocate_integer(stacktop,i);
  89. }
  90. EUFUN_CLOSE
  91.  
  92. EUFUN_1( Fn_list, ll)
  93. {
  94.   /* Say, wow!! Declaring this n-ary gives us it for free... */
  95.  
  96.   return(ll);
  97. }
  98. EUFUN_CLOSE
  99.  
  100. /* For no readily apparent reason... */
  101.  
  102. EUFUN_3( Sf_tilnil,  mod, env, forms)
  103. {
  104.   extern LispObject Sf_progn(LispObject*);
  105.  
  106.   while (Sf_progn(stackbase) != nil);
  107.  
  108.   return(nil);
  109.  
  110. }
  111. EUFUN_CLOSE
  112.  
  113. EUFUN_1( Fn_list_to_string, l)
  114. {
  115.   char buf[512];
  116.   LispObject walker,str;
  117.  
  118.   walker = l; buf[0] = '\0';
  119.   while (is_cons(walker)) {
  120.     if (!is_symbol(CAR(walker)))
  121.       CallError(stacktop,
  122.         "string-to-list: non-symbol in list",l,NONCONTINUABLE);
  123.     strcat(buf,stringof(CAR(walker)->SYMBOL.pname));
  124.     walker = CDR(walker);
  125.   }
  126.  
  127.   str = (LispObject) allocate_string(stacktop,buf,strlen(buf));
  128.  
  129.   return(str);
  130. }
  131. EUFUN_CLOSE
  132.  
  133. /*
  134.  * Module initialisation...
  135.  */
  136.  
  137. #define LISTS_ENTRIES 11
  138. MODULE Module_lists;
  139. LispObject Module_lists_values[LISTS_ENTRIES];
  140.  
  141. void initialise_lists(LispObject* stacktop)
  142. {
  143.   extern LispObject generic_generic_convert;
  144.   LispObject get,set;
  145.  
  146.   open_module(stacktop,
  147.           &Module_lists,
  148.           Module_lists_values,
  149.           "lists",
  150.           LISTS_ENTRIES);
  151.  
  152.   (void) make_module_function(stacktop,"consp",Fn_consp,1);
  153.   (void) make_module_function(stacktop,"cons",Fn_cons,2); /* In allocate.c */
  154.   
  155.   get = make_module_function(stacktop,"car",Fn_car,1);
  156.   STACK_TMP(get);
  157.   set = make_unexported_module_function(stacktop,"car-updator",car_updator,2);
  158.   UNSTACK_TMP(get);
  159.   set_anon_associate(stacktop,get,set);
  160.  
  161.   get = make_module_function(stacktop,"cdr",Fn_cdr,1);
  162.   STACK_TMP(get);
  163.   set = make_unexported_module_function(stacktop,"cdr-updator",cdr_updator,2);
  164.   UNSTACK_TMP(get);
  165.   set_anon_associate(stacktop,get,set);
  166.  
  167.   (void) make_module_function(stacktop,"list-length",Fn_length,1);
  168.   (void) make_module_function(stacktop,"list",Fn_list,-1);
  169.  
  170.   (void) make_module_special(stacktop,"tilnil",Sf_tilnil);
  171.  
  172.   (void) make_module_function(stacktop,"list-to-string",Fn_list_to_string,1);
  173.   (void) make_module_function(stacktop,"generic_generic_convert,Cons,String",
  174.                   Fn_list_to_string,2
  175.                   );
  176.  
  177.   close_module();
  178. }
  179.